home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / MAINR1.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  4KB  |  162 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2.  
  3. unit mainr1;
  4.  
  5. interface
  6.  
  7. uses gentypes,configrt,textret,gensubs,subs1,userret,statret;
  8.  
  9. procedure showinfoforms (uname:mstr; form:integer);  { UNAME='' shows all }
  10. function validfname (name:lstr):boolean;
  11. function searchboard (name:sstr):integer;
  12. function numfeedback:integer;
  13. procedure trimmessage (var m:message);
  14.  
  15. implementation
  16.  
  17. procedure showinfoforms (uname:mstr; form:integer);  { UNAME='' shows all }
  18. var lnum,un,cnt:integer;
  19.     u:userrec;
  20.  
  21.   procedure showone;
  22.   var ff:text;
  23.       fn:lstr;
  24.       me:message;
  25.       k:char;
  26.       found:boolean;
  27.       i:integer;
  28.       teleg:integer;
  29.  
  30.   begin
  31.     if ((u.infoform=-1) and (form=1)) or ((u.infoform2=-1) and (form=2)) or
  32.     ((u.infoform3=-1) and (form=3)) or ((u.infoform4=-1) and (form=4)) or
  33.     ((u.infoform5=-1) and (form=5)) then begin
  34.       writeln (^B'That user has no information form.');
  35.       exit
  36.     end;
  37.     fn:=configset.textfiledi+'infoform';
  38.     if form>0 then fn:=fn+'.'+strr(form);
  39.     assign (ff,fn);
  40.     reset (ff);
  41.     if ioresult<>0 then begin
  42.       close (ff);
  43.       lnum:=ioresult;
  44.       writeln (^B'No information form is present.');
  45.       exit
  46.     end;
  47.     if form=1 then teleg:=u.infoform else if form=2 then teleg:=u.infoform2 else if
  48.     form=3 then teleg:=u.infoform3 else if form=4 then teleg:=u.infoform4 else
  49.     if form=5 then teleg:=u.infoform5;
  50.     reloadtext (teleg,me);
  51.     writeln (^M,me.text[1],^M^M);
  52.     lnum:=1;
  53.     while not (break or eof(ff)) do begin
  54.       read (ff,k);
  55.       if k='|' then begin
  56.         read(ff,k);
  57.         i:=valu(k)*10;
  58.         read(ff,k);
  59.         i:=i+valu(k);
  60.         ansicolor(i);
  61.         read(ff,k)
  62.       end;
  63.       if k='@' then if lnum>me.numlines then writeln('No Answer')
  64.          else begin
  65.          lnum:=lnum+1;
  66.          writeln(me.text[lnum]);
  67.          read(ff,k)
  68.       end;
  69.       if k='*'
  70.         then if lnum>me.numlines
  71.           then writeln ('No answer')
  72.           else begin
  73.             lnum:=lnum+1;
  74.             writeln (me.text[lnum])
  75.           end
  76.         else write (k)
  77.     end;
  78.     textclose (ff)
  79.   end;
  80.  
  81. begin
  82.   if uname='' then begin
  83.     writeln (^B^M'          Showing All Forms');
  84.     seek (ufile,1);
  85.     for cnt:=1 to numusers do begin
  86.       read (ufile,u);
  87.         writeln (^M^M,u.handle,^M);
  88.         showone;
  89.       if xpressed then exit
  90.     end
  91.   end else begin
  92.     un:=lookupuser (uname);
  93.     if un=0 then writeln (^B'No such user.') else begin
  94.       seek (ufile,un);
  95.       read (ufile,u);
  96.       showone
  97.     end
  98.   end
  99. end;
  100.  
  101. function validfname (name:lstr):boolean;
  102. const invalid:set of char=[#0..#31,'"',']','[',':','\','>','<','/','?','*',
  103.   '|','+','=',';', ',' ,#127..#255];
  104. var p,cnt:integer;
  105.     k:char;
  106.     dotfound:boolean;
  107. begin
  108.   validfname:=false;
  109.   dotfound:=false;
  110.   if (length(name)>12) or (length(name)<1) then exit;
  111.   for p:=1 to length(name) do begin
  112.     k:=upcase(name[p]);
  113.     if k in invalid then exit;
  114.     if k='.' then begin
  115.       if dotfound then exit;
  116.       dotfound:=true;
  117.       if (p<length(name)-3) or (p=1) then exit
  118.     end
  119.   end;
  120.   validfname:=not devicename(name)
  121. end;
  122.  
  123. function searchboard (name:sstr):integer;
  124. var bi:sstr;
  125.     cnt:integer;
  126. begin
  127.   seek (bifile,0);
  128.   for cnt:=0 to filesize(bifile)-1 do begin
  129.     read (bifile,bi);
  130.     if match(bi,name) then begin
  131.       searchboard:=cnt;
  132.       exit
  133.     end
  134.   end;
  135.   searchboard:=-1
  136. end;
  137.  
  138. function numfeedback:integer;
  139. var ffile:file of mailrec;
  140. begin
  141.   assign (ffile,'Feedback');
  142.   reset (ffile);
  143.   if ioresult<>0 then begin
  144.     numfeedback:=0;
  145.     rewrite (ffile)
  146.   end else numfeedback:=filesize (ffile);
  147.   close (ffile)
  148. end;
  149.  
  150. procedure trimmessage (var m:message);
  151. var cnt:integer;
  152. begin
  153.   for cnt:=1 to m.numlines do
  154.     while m.text[cnt][length(m.text[cnt])]=' ' do
  155.       m.text[cnt][0]:=pred(m.text[cnt][0]);
  156.   while (m.numlines>0) and (m.text[m.numlines]='') do
  157.     m.numlines:=m.numlines-1
  158. end;
  159.  
  160. begin
  161. end.
  162.